Giga Pack/Giga Pack CD1.iso/cards/labelle3/labelle3.bas

BASIC Source File | 1989-09-16 | 14KB | 349 lines

'La Belle Lucie by George Leotti, July 1988
'Revised by Robert Gellman, November 1988
'Second revision by R. G., September 1989

'The original program was written in Microsoft's QuickBASIC 4.0.
'This version is in QuickBASIC 4.5, but it uses routines from the
'PROBAS library of programming tools.  If you want to modify the
'code but don't have PROBAS, use the original version.
'PROBAS is a product of Hammerly Computer Services.

DEFINT A-Z
CONST true = -1, false = NOT true
DECLARE SUB Initial () : DECLARE SUB DisplayCards ()
DECLARE SUB Shuffle () : DECLARE SUB FindCard (r, x, w, flag)
DECLARE SUB Arrow (rr, cc, erasearrow)
COMMON SHARED r$, s$, cards, m$, dsegh, dofsh, back
DIM SHARED deck(52), pile(24), colr(3), scrnh(2000), scrn(2000)

xcolor = SCREEN(1, 1, 1): CALL Initial

Newgame:                                       'reset for new game
COLOR 15, back: CLS : cards = 52: deal = 2: done = 0
tag$ = "(Q)uit (H)elp (S)huffle"
FOR i = 1 TO 52: deck(i) = i: NEXT: ERASE pile
LOCATE 2, 7: PRINT "La Belle Lucie"; TAB(59); "Deal    Cards"
PRINT TAB(60); deal; TAB(68); cards
CALL Shuffle: CALL DisplayCards                'shuffle and deal

Mainloop:
IF cards = 0 THEN GOTO endhand                 'a winner
LOCATE 24, (40 - (LEN(tag$) / 2)), 1: PRINT tag$;
freemove = false: uploop = false               'flag last shuffle move
GOSUB Getinput                                 'get input
IF rank < 1 THEN bad = 1: GOTO badmove

Movecard:
CALL FindCard(rank, x, w, 0)
IF w = 0 THEN
   IF uploop THEN                              'If cycling foundation
      CALL DisplayCards: GOTO Mainloop         'cards, no error
   ELSE
      bad = 2: GOTO badmove                    'card not available
   END IF
END IF

okaytomove:
IF rank - suit * 13 > 1 THEN                   'move non-aces
   FOR i = 20 TO 23
       IF rank - pile(i) = 1 AND suit = pile(i) \ 13 THEN
          pile(i) = rank: EXIT FOR
       END IF
   NEXT
ELSE                                           'move aces
   FOR i = 20 TO 23
       IF pile(i) = 0 THEN pile(i) = rank: EXIT FOR
   NEXT
END IF
IF rank = pile(i) THEN                         'foundation card found
   pile(w) = pile(w) - 1: cards = cards - 1: deck(x) = 0
   FOR j = x TO cards: SWAP deck(j), deck(j + 1): NEXT
   col = 28 + 6 * (i - 20): r = rank - suit * 13
   COLOR colr(suit), 7                         'display foundation
   LOCATE 1, col: PRINT MID$(r$, r, 1); "    "
   LOCATE 2, col: PRINT CHR$(3 + suit); "    "
   LOCATE 3, col: PRINT "    "; CHR$(3 + suit)
   LOCATE 4, col: PRINT "    "; MID$(r$, r, 1)
   IF r = 13 THEN
      COLOR , back: LOCATE 3, 9 + 2 * (i - 20)
      PRINT CHR$(3 + suit): done = done + 1    'done=completed suit
   END IF
   IF pile(w) = 0 THEN                         'fix hole in tableau
      FOR i = w TO 18: SWAP pile(i), pile(i + 1): NEXT
   END IF
   COLOR 15, back: LOCATE 3, 68: PRINT cards
   IF rank - suit * 13 < 13 THEN               'do range if not king
      uploop = true                            'internal cycle flag
      rank = rank + 1: GOTO Movecard           'do next card in range
   END IF
   CALL DisplayCards: GOTO Mainloop
END IF                                         'end foundation move

                                               'move card in tableau
flag = 1: CALL FindCard(rank1, x1, w1, flag)
IF flag THEN bad = flag: GOTO badmove
pile(w1) = pile(w1) + 1                        'adjust piles
pile(w) = pile(w) - 1
IF x > x1 THEN                                 'move card down in deck
   FOR i = x TO x1 + 2 STEP -1
      SWAP deck(i - 1), deck(i)
   NEXT
ELSE                                           'move card up in deck
   FOR i = x TO x1 - 1
       SWAP deck(i + 1), deck(i)
   NEXT
END IF
IF pile(w) = 0 THEN                            'fix hole in tableau
   FOR i = w TO 18: SWAP pile(i), pile(i + 1): NEXT
END IF
LOCATE 3, 68: PRINT cards
CALL DisplayCards: GOTO Mainloop               'end tableau move

Lastshuffle:
freemove = true                                'set freemove flag
LOCATE 24, 20: CALL clreol
LOCATE , 33, 1: PRINT tag$;
GOSUB Getinput

x = 0: IF rank < 1 THEN bad = 1: GOTO badmove
FOR i = 1 TO cards                             'find card
   IF deck(i) = rank THEN
      x = i: w = x \ 3 + 1 + (x / 3 = x \ 3): EXIT FOR
   END IF
NEXT
IF x = 0 THEN bad = 1: GOTO badmove
GOTO okaytomove

Getinput:
LOCATE 22, 7: CALL clreol: m$ = ""
IF freemove THEN                               'after last shuffle
   COLOR 31: SOUND 5000, .5
   PRINT "Enter a card to draw or move "; : COLOR 15
ELSE PRINT "   What is your move ";
END IF
DO:
   CALL getkey(0, i, j, j, j): z$ = UCASE$(CHR$(i))
   SELECT CASE z$
      CASE CHR$(13): EXIT DO
      CASE CHR$(8)
         IF m$ <> "" THEN
            CALL bkspace(row, col): LOCATE row, col
            m$ = LEFT$(m$, LEN(m$) - 1)
         END IF
      CASE ELSE
         IF INSTR(r$ + s$, z$) <> 0 THEN
            PRINT z$; : m$ = m$ + z$: IF LEN(m$) > 2 THEN EXIT DO
         END IF
    END SELECT
LOOP

LOCATE 22, 7, 0: CALL clreol
SELECT CASE m$
   CASE "Q": GOTO endhand
   CASE "N": GOTO Mainloop                              'help screen
   CASE "H"
      dseg = VARSEG(scrn(1)): dofs = VARPTR(scrn(1))
      CALL dgetscreen(dseg, dofs, 1, 1, 25, 80, 0, 0)   'save screen
      CALL dputscreen(dsegh, dofsh, 1, 1, 25, 80, 0, 0) 'get help
      CALL getkey(0, i, i, i, i)                        'wait for key
      CALL dputscreen(dseg, dofs, 1, 1, 25, 80, 0, 0)   'restore
      LOCATE , , 1: GOTO Getinput
   CASE "S"
      IF deal = 0 THEN
         IF freemove THEN GOTO Getinput ELSE bad = 7: GOTO badmove
      END IF
      CALL Shuffle: deal = deal - 1: LOCATE 3, 60: PRINT deal
      CALL DisplayCards
      IF deal = 0 THEN tag$ = LEFT$(tag$, 14): GOTO Lastshuffle
      GOTO Mainloop
   CASE ELSE
      IF LEN(m$) <> 2 THEN bad = 3: GOTO badmove
'convert input to deck notation                'r is from; r1 is to
      rank = INSTR(r$, LEFT$(m$, 1))           'get rank
      IF rank = 0 THEN RETURN                  'error
      suit = INSTR(s$, MID$(m$, 2, 1)) - 1     'get suit
      rank = suit * 13 + rank                  'value of card, 1-52
      rank1 = rank + 1
END SELECT
RETURN                                         'end of getinput

badmove:                                       'display errors
LOCATE 22, 7: CALL clreol: SOUND 5000, .5
SELECT CASE bad
   CASE 1, 3: PRINT "I don't understand your input."
   CASE 7: PRINT "No shuffles left!"
   CASE ELSE: PRINT "That card can't be moved."
              CALL Arrow(rr, cc, erasearrow)   'show card location
END SELECT
CALL delay18th(20)                             'wait 1 second +
IF erasearrow THEN LOCATE rr, cc: PRINT " ": COLOR 15, back
IF freemove THEN GOTO Lastshuffle              'if move available
GOTO Mainloop

endhand:
FOR i = 6 TO 25: LOCATE i, 1: CALL clreol: NEXT
IF cards = 0 THEN                               'game won
   won = won + 1: bonus = 10: LOCATE 3, 9
   FOR j = 1 TO deal + 1
       FOR i = 1 TO 5: SOUND 500 * i, .6: NEXT
   NEXT
   FOR i = 20 TO 23                             'flash suit symbols
       j = pile(i) \ 13 - 1: COLOR 16 + colr(j)
       PRINT CHR$(3 + j); " ";
   NEXT: COLOR 15
ELSE lost = lost + 1
END IF

score = done * 20 + 52 - (cards + done * 13) + bonus * deal
totalscore = totalscore + score
LOCATE 8, 27: PRINT "Score for this game is"; STR$(score)
LOCATE 10, 23: PRINT "You've won"; won; "game";
PRINT STRING$(ABS(won > 1 OR won = 0), 115); " and lost"; lost;
PRINT "game"; STRING$(ABS(lost > 1 OR lost = 0), 115);
left = left + cards: average! = left / (won + lost)
avgscore! = totalscore / (won + lost)
LOCATE 12, 23: PRINT "Average score this session is ";
PRINT USING "###.#"; avgscore!
LOCATE 14, 23: PRINT "Average number of cards left is ";
PRINT USING "##.#"; average!

IF cards > 0 THEN LOCATE 18, 27: PRINT "Hit R to resume last game"
LOCATE 20, 29: PRINT "Hit Q to return to DOS"
LOCATE 22, 24: PRINT "Hit any other key for a new game"
CALL getkey(0, i, j, j, j)
SELECT CASE UCASE$(CHR$(i))
  CASE "Q": COLOR xcolor MOD 16, xcolor \ 16: CLS : LOCATE , , 1: END
  CASE "R": lost = lost - 1: left = left - cards
            totalscore = totalscore - score
            CALL DisplayCards: IF freemove THEN GOTO Lastshuffle
            LOCATE 24, (40 - (LEN(tag$) / 2)), 1: PRINT tag$;
            GOTO Getinput
  CASE ELSE: bonus = 0: GOTO Newgame
END SELECT                                     'end endhand

DATA "   The object is to move all cards from the tableau to the"
DATA "foundation in ascending order, Ace through King by suit.",""
DATA "   18 piles are dealt to the tableau.  17 piles of 3 cards, and"
DATA "1 pile with 1 card.  Move cards within the tableau by suit in"
DATA "descending order (e.g. 7S on the 8S).  Only the TOP (right-most)"
DATA "card in a pile can be moved either to a foundation or to another"
DATA "tableau pile.  Kings can only be moved to the foundation.",""
DATA "   Designate moves with two characters.  For example, '7S' means"
DATA "move 7 of Spades.  The computer will first try a foundation pile"
DATA "and then the tableau.  If the 7 can go on a foundation, the"
DATA "computer will automatically move the 8,9, etc, if available.",""
DATA "   You are allowed two reshuffles.  On the final shuffle, you may"
DATA "move ONE card from ANYWHERE in a tableau pile to the foundation,"
DATA "OR to a top card in the tableau according to the above rules. "
DATA "Enter an 'S' at the prompt to shuffle the cards.",""
DATA "   Enter 10's as 'T', Jacks as 'J', Queens as 'Q', Kings as 'K'."

SUB Arrow (rr, cc, erasearrow) STATIC
i = 1: x = pile(1): c = 1: row = 6: col = 10: erasearrow = false
DO WHILE x
   FOR j = 0 TO x - 1: d = deck(c + j)         'get card number
      suit = d \ 13 + (d \ 13 = d / 13)        'change it to suit
      z$ = MID$(r$, d - suit * 13, 1)          '& rank
      IF z$ = LEFT$(m$, 1) THEN
         IF INSTR(s$, (MID$(m$, 2, 1))) - 1 = suit THEN
             erasearrow = true: COLOR 31: rr = row - 1: cc = col + j
             LOCATE rr, cc: PRINT ""; : EXIT SUB
         END IF
      END IF
   NEXT
   i = i + 1: col = col + 5 + x: c = c + j: x = pile(i)
   IF col + x + 4 > 75 THEN col = 10: row = row + 5
LOOP
END SUB

SUB DisplayCards STATIC                        'display tableau
FOR i = 6 TO 20: LOCATE i, 1: CALL clreol: NEXT
i = 1: x = pile(1): c = 1: row = 6: col = 10
DO WHILE x
   FOR j = 0 TO x - 1: d = deck(c + j)         'get card number
      suit = d \ 13 + (d \ 13 = d / 13)        'change it to suit
      m$ = MID$(r$, d - suit * 13, 1)          '& rank
      COLOR colr(suit), 7
      LOCATE row, col + j: PRINT m$            'print it (upper left)
      LOCATE row + 1, col + j: PRINT CHR$(3 + suit)
   NEXT: x$ = STRING$(3 + x, 32)
   LOCATE row, col + j: PRINT "    "           'display rest of pile.
   LOCATE row + 1, col + j: PRINT "    "
   LOCATE row + 2, col: PRINT x$; CHR$(3 + suit)
   LOCATE row + 3, col: PRINT x$; m$
   i = i + 1: col = col + 5 + x: c = c + j: x = pile(i)
   IF col + x + 4 > 75 THEN col = 10: row = row + 5
LOOP
COLOR 15, back
END SUB

SUB FindCard (r, x, w, flag) STATIC
SHARED rank, suit
x = 0: w = 0
FOR i = 1 TO 18                                'check top card for
   x = x + pile(i)                             'a match with r
   IF deck(x) = r THEN w = i: EXIT FOR
NEXT
IF flag = 0 THEN EXIT SUB ELSE flag = 0
IF w = 0 OR rank - suit * 13 = 13 THEN flag = 2
END SUB

SUB Initial STATIC
'initialize colors; create virtual help screen

r$ = "A23456789TJQK": s$ = "HDCS"
colr(0) = 4: colr(1) = 4: back = 2: CALL getcrt(i)
red = 36: black = 32: blue = 31: yellow = 30: hue = true
IF NOT i OR INSTR(COMMAND$, "B") <> 0 THEN
   ERASE colr: hue = false
   back = 0: red = 15: black = 15: blue = 15: yellow = 15
END IF

'create virtual screen to hold help screen
dsegh = VARSEG(scrnh(1)): dofsh = VARPTR(scrnh(1))
CALL dclear(dsegh, dofsh, blue)                'clear virtual screen
z$ = "How to play La Belle Lucie"
i = 0: j = 15: IF hue THEN i = 1: j = 14
CALL dwindowmanager(dsegh, dofsh, 2, 2, 24, 79, 2, 15, i, 0, 0, j, z$)
FOR i = 3 TO 22                                'write to virtual screen
    READ z$: CALL dxqprint(dsegh, dofsh, z$, i, 8, blue)
NEXT
z$ = "<Hit any key to continue>"
CALL dxqprint(dsegh, dofsh, z$, 24, 27, yellow) 'write last line

COLOR 15, back: CLS : RANDOMIZE TIMER          'opening screen
CALL bigprint(CHR$(6), CHR$(6), 8, 5, black)
CALL bigprint(CHR$(3), CHR$(3), 9, 19, red)
CALL bigprint(CHR$(4), CHR$(4), 9, 54, red)
CALL bigprint(CHR$(5), CHR$(5), 8, 68, black)
LOCATE 24, 29: PRINT "Press any key to begin";
COLOR 15: IF hue THEN COLOR 0
LOCATE 18, 62: c = 2
PRINT "Programmed by": LOCATE , 62: PRINT "George Leotti"
LOCATE , 62: PRINT "Modified by": LOCATE , 62: PRINT "Robert Gellman"
LOCATE , 62: PRINT "Rel. 3.0  9/89"
IF hue THEN
   COLOR 15, 0: LOCATE 24, 12
   PRINT "To suppress color, exit and restart like this: LABELLE/B";
   DO: LOCATE 12, 33
       FOR i = 1 TO 15
          COLOR colr(ABS(c \ 2 = c / 2) + 1), 2
          IF c = 2 THEN c = 3 ELSE c = 2
          PRINT MID$("La Belle Lucie ", i, 1);
       NEXT
       CALL delay18th(3): CALL keypress(i)
   LOOP UNTIL i: CALL clrkbd
ELSE
LOCATE 12, 33: PRINT "La Belle Lucie"
CALL getkey(0, i, i, i, i)
END IF
END SUB

SUB Shuffle STATIC
FOR i = 1 TO cards: SWAP deck(i), deck(INT(RND * cards + 1)): NEXT
FOR i = 1 TO cards \ 3: pile(i) = 3: NEXT
pile(i) = cards MOD 3                          'last pile gets rest
pile(i + 1) = 0                                'last pile marker
END SUB